home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 001 / fxmodem.arc / NXMODEM.FOR next >
Encoding:
Text File  |  1987-09-11  |  29.0 KB  |  1,134 lines
  1.  
  2.  
  3. c
  4. c        MODEM7-type program to send and
  5. c        receive files with checksums or CRC and automatic
  6. c        re-transmission of bad blocks.
  7. c        translated to VAX Fortran V3.0 from TMODEM.C by
  8. c        and enhanced according to time-outs and CRC
  9. C        in XMODEM50.ASM
  10. c        J.James Belonis II
  11. c        Physics Hall FM-15
  12. c        University of Washington
  13. c        Seattle, WA 98195
  14. c
  15. c  TMODEM.C written by Richard Conn, Eliot Moss, and Lauren
  16. c   Weinstein
  17. c
  18. c  6/30/83  Modified, restructured, and VAX/VMS text file
  19. c    conversion added by Richard Conn
  20. c  1/17/83    touched up filename display and comments.
  21. c  1/14/83    including timeouts and CTRL-X cancellation
  22. c        and CRC capability
  23. c
  24. c  keeps a log file of error messages ( deletes it if no errors )
  25. c  sets terminal driver to eightbit, passall
  26. c  may need altypeahd if faster than 1200 baud works to 9600 baud at least.
  27. c  needs PHY_IO privilege for passall ? apparently not on UWPhys VAX
  28. c  nor on ACC VAX
  29. c  many debugging statements left in as comments
  30.  
  31. c  declare variables
  32.     include 'QIO.DCK'
  33.     character*80 line, file, workf
  34.     integer sloc, worklen
  35.  
  36.     logical filedel
  37.     common /filest/filedel
  38.  
  39.     integer errorcount
  40.     common /err/errorcount
  41.  
  42.     integer high,low
  43.     common /crcval/high,low
  44.  
  45.     logical crc
  46.     integer checksum
  47.     common /checks/checksum,crc
  48.  
  49.     equivalence (checksum,checksumbyte)
  50.     equivalence (ic,c)
  51.  
  52. c  define ascii characters
  53.     parameter NUL=0        !ignore at SOH time
  54.     parameter SOH=1        !start of header for sector
  55.     parameter EOT=4        !end of transfer
  56.     parameter ACK=6        !acknowlege sector
  57.     parameter NAK=21    !not acknowlege sector
  58.     parameter CAN=24    !cancel transfer
  59.     parameter CRCCHAR='C'    !CRC indicating character
  60.  
  61. c  timeouts
  62.     parameter respnaklim=10    !seconds to allow for response to NAK
  63.     parameter naklim=10     !seconds to allow to receive first NAK
  64.     parameter eotlim=10    !seconds to wait for EOT acknowlege
  65.  
  66.     parameter errlim=10    !max errors on a sector
  67.  
  68. c  define an exit routine to get control on all exits to turn off
  69. c  passall and for debug cleanup
  70.     external giveup
  71.     call userex( giveup )
  72.  
  73.     print *,' XMODEM Version 5.1 on VAX VMS'
  74. c  log file for debugging
  75.     open(8,file='XMODEM.LOG',carriagecontrol='LIST',status='NEW')
  76. c  assign terminal channel for QIO calls to send raw bytes.
  77.     call sys$assign('TT',chan,,)
  78.  
  79. c  name work file
  80.     workf='XMODEM.WRK '
  81.     worklen=10    ! number of chars in file name
  82. c  get command line
  83.     call lib$get_foreign(line,'$_XMODEM Command: ',)
  84. c  trim blanks
  85.     do i=80,1,-1
  86.         if(line(i:i).NE.' ') goto 25
  87.         len=i
  88.     enddo
  89.   25    continue
  90.  
  91. c  set to NOT delete working file
  92.     filedel=.false.
  93.  
  94. c  send
  95.     sloc=index(line,'S ')
  96.     if(sloc.NE.0) then
  97.         file=line(sloc+2:)
  98.         len=len-2
  99.         crc=.false.
  100.         print *,' Sending File: ',file(1:len)
  101.         call sendfile(file,len)
  102.         call exit
  103.     endif
  104. c  send text
  105.     sloc=index(line,'ST ')
  106.     if(sloc.NE.0) then
  107.         file=line(sloc+3:)
  108.         len=len-3
  109.         crc=.false.
  110.         print *,' Sending Text File: ',file(1:len)
  111.         call vtoc(file,workf)
  112.         filedel=.true.    !delete working file when done
  113.         call sendfile(workf,worklen)
  114.         call exit
  115.     endif
  116. c  send with CRC
  117.     sloc=index(line,'SC ')
  118.     if (sloc.NE.0) then
  119.         file=line(sloc+3:)
  120.         len=len-3
  121.         crc=.true.
  122.         print *,' Sending File: ',file(1:len),' using CRCs'
  123.         call sendfile(file,len)
  124.         call exit
  125.     endif
  126. c  receive with checksum
  127.     sloc=index(line,'R ')
  128.     if(sloc.NE.0) then
  129.         file=line(sloc+2:)
  130.         len=len-2
  131.         crc=.false.
  132.         print *,' Receiving File: ',file(1:len)
  133.         call recvfile(file,len)
  134.         call exit
  135.     endif
  136. c  receive text with checksum
  137.     sloc=index(line,'RT ')
  138.     if(sloc.NE.0) then
  139.         file=line(sloc+3:)
  140.         len=len-3
  141.         crc=.false.
  142.         print *,' Receiving Text File: ',file(1:len)
  143.         call recvfile(workf,worklen)
  144.         filedel=.true.    !delete working file when done
  145.         call ctov(workf,file)
  146.         call exit
  147.     endif
  148. c  receive with CRC
  149.     sloc=index(line,'RC ')
  150.     if(sloc.NE.0) then
  151.         file=line(sloc+3:)
  152.         len=len-3
  153.         crc=.true.
  154.         print *,' Receiving File: ',file(1:len),' using CRCs'
  155.         call recvfile(file,len)
  156.         call exit
  157.     endif
  158.  
  159. c  else bad command
  160.     print *,' Invalid XMODEM Command --'
  161.     print *,' Usage: XMODEM  <S, ST, SC, R, RT, or RC>  <file> '
  162.     print *,'   S = Send, R = Receive, C = Use CRCs'
  163.     print *,'   T = Convert CP/M to VAX/VMS and VAX/VMS to CP/M Text Files'
  164.     call exit
  165.     end
  166.  
  167. c----------------------------------------------------------------
  168. c  send file
  169.     subroutine sendfile(file,len)
  170.  
  171. c  declare variables
  172.     include 'QIO.DCK'
  173.     character*80 file
  174.     byte sector(130), c
  175.     integer blocknumber, nakwait, stat, ic
  176.     logical ttyinlim
  177.     logical charintime, acked
  178.  
  179.     logical filedel
  180.     common /filest/filedel
  181.  
  182.     integer errorcount
  183.     common /err/errorcount
  184.  
  185.     integer high,low
  186.     common /crcval/high,low
  187.  
  188.     logical crc
  189.     integer checksum
  190.     common /checks/checksum,crc
  191.  
  192.     equivalence (checksum,checksumbyte)
  193.     equivalence (ic,c)
  194.  
  195. c  define ASCII characters
  196.     parameter NUL=0
  197.     parameter SOH=1
  198.     parameter EOT=4
  199.     parameter ACK=6
  200.     parameter NAK=21
  201.     parameter CAN=24
  202.     parameter CRCCHAR='C'
  203. c  timeouts
  204.     parameter respnaklim=10
  205.     parameter naklim=10
  206.     parameter eotlim=10
  207.     parameter errlim=10
  208.  
  209.     open(6,name=file(1:len),iostat=stat,status='OLD')
  210. c     1        carriagecontrol='NONE',recordtype='FIXED',recl=128)
  211.  
  212.     if(stat) then
  213.         print *,'Can''t open',file(1:len),' for send.'
  214.         call exit
  215.     endif
  216.     if(crc) then
  217.         print *,' CRC Transfer Mode'
  218.     else
  219.         print *,' Checksum Transfer Mode'
  220.     endif
  221.     print *,file(1:len),' Open -- Please Run Your Receiver --'
  222.     print *
  223.     errorcount=0
  224.     blocknumber=1
  225.     nakwait=0
  226.  
  227. c  await first NAK (or 'C') indicating receiver is ready
  228.   200    charintime=ttyinlim(c,1,naklim)        ! return NUL if timeout
  229. c    print *,' character=',c
  230.     if( .NOT.charintime ) then
  231.         nakwait=nakwait+1
  232. c  give the turkey 80 seconds to figure out how to receive a file
  233.         if(nakwait.EQ.80) call cancel
  234.         goto 200
  235.     elseif(c.EQ.NAK) then
  236.         crc=.false.
  237.     elseif(c.EQ.CRCCHAR) then
  238.         crc=.true.
  239.     elseif(c.EQ.CAN) then
  240.         call cancel
  241.     else
  242. c  unrecognized character
  243.         nakwait=nakwait+1
  244.         if(nakwait.eq.80) call cancel
  245.         goto 200
  246.     endif
  247.     
  248.   300    continue
  249. c  send new sector
  250.     read(6,1000,end=500) (sector(i),i=1,128)
  251.  1000    format(128a)
  252.     errorcount=0
  253. c    print *,' sector as read',sector
  254.   400    continue
  255. c  send sector
  256. c    print *,' SOH '
  257.     call ttyout(SOH,1)
  258.     call ttyout(blocknumber,1)
  259.     call ttyout( not(blocknumber),1 )
  260. c    print *,' blocknumber=',blocknumber
  261.  
  262.     checksum=0
  263.     call clrcrc
  264. c  separate calls to slow down in case other end slow (can even introduce
  265. c  delay between characters).
  266. c    do i=1,128
  267. c        call ttyout(sector(i),1)
  268. c    enddo
  269.     call ttyout(sector,128)
  270.  
  271. c  calc checksum or crc
  272.     if(crc) then
  273. c  put all bytes + two finishing zero bytes through updcrc
  274.         sector(129)=0
  275.         sector(130)=0
  276.         call updcrc( sector,130 )
  277.         call ttyout(high,1)
  278.         call ttyout(low,1)
  279.     else
  280.         do i=1,128
  281.             checksum=checksum+sector(i)
  282.         enddo
  283. c  this sends low order byte of checksum
  284.         call ttyout(checksum,1)
  285. c        print *,' checksum',checksum
  286.     endif
  287.  
  288. c  sector sent, see if receiver acknowleges
  289. c  getack attempts to get ACK
  290. c  if not, repeat sector
  291. c    print*, ' should wait for ACK 10 seconds'
  292.     call getack(acked)
  293. c    print*, ' getack returned=',acked
  294.     if(.NOT.acked) goto 400
  295.  
  296. c  ACK received, send next sector
  297.     blocknumber=blocknumber+1
  298.     goto 300
  299.  
  300. c  end of file during read.  finish up sending.
  301.   500    continue
  302.     call ttyout(EOT,1)
  303. c  getack attempts to get ACK up to errlim times
  304.     call getack(acked)
  305.     if( .NOT.acked ) goto 500
  306.  
  307. c    print *,' Sending complete.'
  308.     if (filedel) then
  309.         close(6,dispose='DELETE')
  310.     else
  311.         close(6)
  312.     endif
  313.     close(8,dispose='DELETE')
  314.     return
  315.     end
  316.  
  317. c----------------------------------------------------------------
  318. c  receive file
  319.     subroutine recvfile(file,len)
  320.  
  321. c  declare variables
  322.     include 'QIO.DCK'
  323.     character*80 file
  324.     byte sector(130), c, notc, checksumbyte, ck
  325.     integer blocknumber, inotc, notnotc, secbytes, stat
  326.     integer testblock, testprev, ic
  327.     logical ttyinlim
  328.     logical charintime, firstsoh
  329.  
  330.     integer errorcount
  331.     common /err/errorcount
  332.  
  333.     integer high,low
  334.     common /crcval/high,low
  335.  
  336.     logical crc
  337.     integer checksum
  338.     common /checks/checksum,crc
  339.  
  340.     equivalence (checksum,checksumbyte)
  341.     equivalence (ic,c)
  342.  
  343. c  define ASCII characters
  344.     parameter NUL=0
  345.     parameter SOH=1
  346.     parameter EOT=4
  347.     parameter ACK=6
  348.     parameter NAK=21
  349.     parameter CAN=24
  350.     parameter CRCCHAR='C'
  351. c  timeouts
  352.     parameter respnaklim=10
  353.     parameter naklim=10
  354.     parameter eotlim=10
  355.     parameter errlim=10
  356.  
  357.     open(7,name=file(1:len),recl=128,status='NEW',iostat=stat,
  358.      1        carriagecontrol='NONE',recordtype='FIXED')
  359.     if(stat) then
  360.         print *,' Can''t open ',file(1:len),' for recieve.'
  361.         call exit
  362.     endif
  363.  
  364.     print *,' Please Send Your File --'
  365.     print *
  366.     call passall(CHAN,.TRUE.)
  367.  
  368.     secbytes=129
  369.     if(crc) then
  370.         secbytes=130
  371.     endif
  372.  
  373.     firstsoh=.false.
  374.     errorcount=0
  375.     blocknumber=1
  376.  
  377. c  start the sender by letting ttyinlim time-out in getack routine
  378. c  so it sends a NAK or C
  379.     goto 999
  380.  
  381.   800    continue
  382. c    write(8,*) ' ready for SOH'
  383. c  must allow enough time for other's disk read (xmodem50.asm allows 10 sec)
  384.     charintime=ttyinlim(c,1,respnaklim)
  385. c  if no char for a while, try NAK or C again
  386.     if( .NOT.charintime ) then
  387. c        print*,' no response to NAK or C, trying again'
  388.         write(8,*) ' no response to NAK or C, trying again'
  389.         goto 999
  390.     endif
  391. c  else received a char so see what it is
  392.     if(c.eq.NUL) goto 800    ! ignore nulls here for compatablity with old
  393.                 ! versions of modem7
  394.     if(c.EQ.CAN) then
  395.         print *,' Canceled.  Aborting.'
  396.         write(8,*) ' Canceled.  Aborting.'
  397.         call exit
  398.     endif
  399. c    write(8,*) ' EOT or SOH character=',c
  400.     if(c.NE.EOT) then
  401.         IF(c.NE.SOH) then
  402.             write(8,*) ' Not SOH, was decimal ',c
  403.             goto 999
  404.         endif
  405.         firstsoh=.true.
  406.  
  407. c  character was SOH to indicate start of header
  408. c  get block number and complement
  409.         call ttyin(c,1)
  410. c        write(8,*) ' block=',c
  411.  
  412.         call ttyin(notc,1)
  413. c        write(8,*) ' block complement=',notc
  414.         inotc=notc    ! make integer for "not" function
  415.         notnotc=iand( not(inotc),255 )    ! mask back to byte
  416.  
  417. c  c is low order byte of ic via equivalence statement
  418.         if(ic.NE.notnotc) then
  419.             write(8,*) ' block check bad.'
  420.             goto 999
  421.         endif
  422. c  block number valid but not yet checked against expected
  423.  
  424. c  clear checksum and CRC
  425.         checksum=0
  426.         call clrcrc
  427.  
  428. c  receive the sector and checksum bytes in one call (for speed).
  429. c  secbytes is 129 for checksum, 130 for CRC
  430.         call ttyin(sector,secbytes)
  431.  
  432.         if(crc) then
  433. c  put data AND CRC bytes through updcrc
  434.             call updcrc(sector,secbytes)
  435. c  if result non-zero, BAD.
  436.             if(iand(high,255).NE.0
  437.     1        .OR.iand(low,255).NE.0) then
  438. c                write(8,*) ' CRC, high,low='
  439. c                write(8,3000) high,low
  440. c 3000                format(2z10)
  441.                 goto 999
  442.             endif
  443.         else
  444. c  don't add received checksum byte to checksum
  445.             do i=1,secbytes-1
  446.                 checksum=checksum+sector(i)
  447.             enddo
  448.             ck=sector(129)
  449. c            write(8,2100) ck
  450.  
  451. c            write(8,2100) checksum
  452. c            write(8,2100) checksumbyte
  453. c 2100            format(' checksum=',z10)
  454.             if( checksumbyte.NE.ck ) then
  455.                 write(8,*) ' bad checksum'
  456.                 goto 999
  457.             endif
  458.         endif
  459.  
  460. c  received OK so we can believe the block number, see which block it was
  461. c  mask it to be one byte
  462.         testblock=iand(blocknumber,255)
  463.         testprev=iand( blocknumber-1 ,255)
  464.         if( ic.EQ.testprev) then
  465.             write(8,*) ' prev. block again, out of synch'
  466. c  already have this block so don't write it, but ACK anyway to resynchronize
  467.             goto 985
  468.         elseif( ic.NE.testblock ) then
  469.             write(8,*) ' block number bad.'
  470.             goto 999
  471.         endif
  472. c  else was expected block
  473.  
  474. c  write before acknowlege so not have to listen while write.
  475.         write(7,2000,err=900) (sector(i),i=1,128)
  476.  2000        format(128a)
  477.         goto 975
  478.   900        write(8,*) ' Can''t write sector. Aborting.'
  479.         print*, ' Can''t write sector. Aborting.'
  480.         call exit
  481.  
  482.   975        continue
  483. c  recieved sector ok, wrote it ok, so acknowlege it to request next.
  484.         blocknumber=blocknumber+1
  485. c  comes here if re-received the previous sector
  486.   985        continue
  487.         errorcount=0
  488. c        write(8,*) ' ACKing, sector was ok.'
  489.         call ttyout(ACK,1)
  490.         goto 800
  491.  
  492. c  else error so eat garbage in case out of synch and try again
  493.   999        continue
  494.         call eat
  495.         write(8,*) ' receive error NAK, block=',blocknumber
  496.         if(crc.AND..NOT.firstsoh) then
  497. c  keep sending 'C'  'til receive first SOH
  498.             call ttyout(CRCCHAR,1)
  499.         else
  500.             call ttyout(NAK,1)
  501.         endif
  502.         errorcount=errorcount+1
  503.   998        if(errorcount.GE.errlim) then
  504.             print*,' Unable to receive block. Aborting.'
  505.             write(8,*) ' Not receive block. Aborting.'
  506. c  delete incompletely received file
  507.             close(7,dispose='DELETE')
  508.             call exit
  509.         endif
  510. c  retry
  511.         goto 800
  512.     endif
  513.  
  514. c  EOT received instead of SOH so file done.
  515. c  should keep sending ACK 'til no more EOT's ?
  516.     close(6)
  517.     close(7)
  518.     call ttyout(ACK,1)
  519.     call ttyout(ACK,1)
  520.     call ttyout(ACK,1)
  521.  
  522. c    write(8,*) ' Completed.'
  523. c    print *,   ' Completed.'
  524. c  transfer ok, so delete the error log file.
  525. c    close(8,status='DELETE')
  526.     close(8,dispose='DELETE')
  527.     return
  528.     end
  529.  
  530. c-------------------------------------------------------------
  531.     subroutine ctov(input,output)
  532. c  convert file of XMODEM 128 byte records with embedded <CR><LF>
  533. c  marking end-of-line and CTRL-Z marking end-of-file
  534. c  to carriage-control=LIST (normal VAX editable file)
  535.  
  536.     character*80 input,output
  537.     character*300 line
  538.     character*1 CR,LF,recchar
  539.     integer blank
  540.     logical eof, eol
  541.  
  542.     logical filedel
  543.     common /filest/filedel
  544.  
  545.     data eof,eol/.false.,.false./
  546.  
  547.     CR=char(13)
  548.     LF=char(10)
  549.  
  550.     open(6,file=input,status='OLD')
  551. c  set maximum output record length to 300 (fortran default is 133)
  552.     open(7,file=output,status='NEW',carriagecontrol='LIST',recl=300)
  553.  
  554. c  getchar (read new record if no input characters left)
  555. c  if EOF on input, write line and exit
  556. c  if CR then
  557. c    if getchar LF then write line
  558. c    else put back char and putchar CR into line (error if too long)
  559. c    endif
  560. c  else putchar (write error message if line too long)
  561. c  endif
  562. c  loop
  563.  
  564.   100    call getc(recchar,eof,eol)
  565.     if(eof) goto 200
  566.     if(recchar.eq.CR) then
  567. c    PRINT *,' CR'
  568.         call getc(recchar,eof)
  569.         if(eof.or.recchar.ne.LF) then
  570.             call putback
  571.             
  572.             len=len+1
  573.             if(len.ge.301) print *,' Out line too long.'
  574. c    print*,' too long line=',line
  575.             line(len:len)=recchar
  576.         else
  577. c  was LF
  578. c    PRINT *,' LEN=',LEN
  579. c    print*,' after LF, line=',line(1:len)
  580.             write(7,2000) line(1:len)
  581.             len=0
  582.         endif
  583.     else
  584. c  not CR, was "ordinary" character
  585.         len=len+1
  586.         if(len.ge.301) then
  587.             print *,' Out line too long.'
  588. c            PRINT *,' LINE=',LINE(1:len)
  589.         endif
  590.         line(len:len)=recchar
  591.     endif
  592.  
  593.     go to 100
  594.  
  595. c  flush last line and exit
  596.   200    continue
  597.     if(len.ne.0) then
  598.         write(7,2000) line(1:len)
  599.  2000        format(a)
  600.     endif
  601.     if (filedel) then
  602.         close(6,dispose='DELETE')
  603.     else
  604.         close(6)
  605.     endif
  606.     close(7)
  607.     return
  608.       end
  609. c-------------------------------------------------------------
  610.     subroutine vtoc(input,output)
  611. c  convert VAX text file to
  612. c  file of XMODEM 128 byte records with embedded <CR><LF>
  613.  
  614.     character*80 input,output
  615.     character*1 CR,LF,c
  616.     integer blank
  617.     logical eof,eol
  618.     data eof,eol/.false.,.false./
  619.  
  620.     CR=char(13)
  621.     LF=char(10)
  622.  
  623.     open(6,file=input,status='OLD')
  624.     open(7,file=output,status='NEW',carriagecontrol='LIST',
  625.     1                  recl=128,recordtype='FIXED')
  626.  
  627. c  getchar (read new line if no input characters left)
  628. c  putchar ( output record if full, close if EOF )
  629. c  if EOL on input, putchar CR putchar LF (output record if full)
  630. c  loop
  631.  
  632.   100    call getv(c,eof,eol)
  633.     if(.not.eol) then
  634.         call putchar(c,eof)
  635.         if(eof) then
  636.             return
  637.         endif
  638.     else
  639. c  end of line
  640.         call putchar(CR,eof)
  641.         call putchar(LF,eof)
  642.         eol=.false.
  643.         if(eof) then
  644.             return
  645.         endif
  646.     endif
  647.     go to 100
  648.  
  649.       end
  650. c------------------------------------------
  651.     subroutine putchar(c,eof)
  652.     character*1 c
  653.     logical eof
  654. c  put character into record (write record if necessary)
  655. c  if eof, fills out rest of record with CTRL-Z's and exits
  656.     character*1 CTRLZ
  657.     character*128 record
  658.     integer point
  659.     common /reccom/point,record
  660.     data point/0/
  661.  
  662.     if(eof) goto 200
  663.     point=point+1
  664. c  strip parity in case VAX file had it
  665.     record(point:point)=char(iand(ichar(c),127))
  666. c    print*,' record(point:point)=',record(point:point)
  667. c    print*,' point=',point
  668.    50    if(point.ge.128) then
  669. c        print*,' record=',record
  670.   100        write(7,1000) record
  671.  1000        format(a)
  672.         point=0
  673.     endif
  674.     return        
  675.  
  676. c  EOF fill record with 26's (CTRL-Z, CP/M end of file mark for ASCII)
  677. c  output last record and exit
  678.   200    continue
  679. c    print*,' in putchar EOF section'
  680.     CTRLZ=char(26)
  681.     do i=point+1,128
  682.         record(i:i)=CTRLZ
  683.     enddo
  684. c    print*,' record=',record
  685.     write(7,1000) record
  686.     close(6)
  687.     close(7)
  688.     return
  689.     end
  690. c------------------------------------------
  691.     subroutine getc(c,eof)
  692. c  get character from a CP/M text file
  693.     character*1 c
  694.     logical eof
  695. c  point to next character in record (read record if necessary)
  696.     character*128 record
  697.     character*1 CTRLZ
  698.     integer point
  699.     logical firsttime
  700.     common /reccom/point,record,firsttime
  701.     data point/0/
  702.     data firsttime/.true./
  703.  
  704.     CTRLZ=char(26)
  705.     point=point+1
  706.     if(point.gt.128.or.firsttime) then
  707.         firsttime=.false.
  708.   100        read(6,1000,end=200) record
  709.  1000        format(a)
  710. c        PRINT *,RECORD
  711.         point=1
  712.     endif
  713. c  strip parity in case CP/M file had it
  714.     c=char(iand(ichar(record(point:point)),127))
  715.     if(c.eq.CTRLZ) eof=.true.
  716.     return
  717.  
  718.   200    eof=.true.
  719.     return
  720.     end
  721. c-------------------------------------------
  722.     subroutine getv(inchar,eof,eol)
  723.     character*1 inchar
  724.     logical eof,eol
  725. c  get character from input line (read line if necessary)
  726. c  returns character and eol=.true. if no more char on line
  727. c  returns eof if end of file (no character)
  728.     character*255 line
  729.     integer len, pos
  730.     logical firsttime
  731.     common/lincom/pos,len,line
  732.     data pos/0/
  733.  
  734.     if(pos.eq.0) then
  735.         read(6,1000,end=100)len,line(1:len)
  736.  1000        format(q,a)
  737. c        print*,' line=',line
  738.     endif
  739.     pos=pos+1
  740.     if(pos.gt.len) then
  741.         eol=.true.
  742.         pos=0
  743.         return
  744.     endif
  745. c    print*,' pos=',pos,' line(1:pos)=',line(1:pos)
  746. c    print*,' line(pos:pos)=',line(pos:pos)
  747.     inchar=line(pos:pos)
  748. c    print*,' pos,char',pos,inchar
  749.     return
  750.  
  751. c  EOF
  752.   100    continue
  753.     eof=.true.
  754.     return
  755.     end
  756. c----------------------------------------------
  757.     subroutine putback
  758. c  point to previous input character so this character will be getchar result
  759. c  even works if 1st char of record
  760.     integer point
  761.     logical eof
  762.     common /reccom/point
  763.  
  764.     point=point-1
  765.     return
  766.     end
  767.  
  768. c-----------------------------------------------------------
  769.     subroutine clrcrc
  770. c  clears CRC
  771.     integer high,low
  772.     common /crcval/high,low
  773.  
  774.     high=0
  775.     low=0
  776.     return
  777.     end
  778. c-----------------------------------------------------------
  779.     subroutine updcrc(bbyte,n)
  780.     byte bbyte(*)
  781.     integer n
  782. c  updates the Cyclic Redundancy Code
  783. c  uses x^16 + x^12 + x^5 + 1 as recommended by CCITT
  784. c    and as used by CRCSUBS version 1.20 for 8080 microprocessor
  785. c    and incorporated into the MODEM7 protocol of the CP/M user's group
  786. c
  787. c  during sending:
  788. c  call clrcrc
  789. c  call updcrc   for each byte
  790. c  call fincrc   to finish (or just put 2 extra zero bytes through updcrc)
  791. c  result to send is low byte of high and low in that order.
  792. c
  793. c  during reception:
  794. c  call clrcrc
  795. c  call updcrc   all bytes PLUS the two received CRC bytes must be passed
  796. c       to this routine
  797. c       then zero in high and low means good checksum
  798. c
  799. c  see Computer Networks, Andrew S. Tanenbaum, Prentiss-Hall, 1981
  800. c
  801. c  must declare integer to allow shifting
  802.     integer byte
  803.     integer high
  804.     integer low
  805.     common /crcval/high,low
  806.     integer bit,bitl,bith
  807.  
  808. c    write(8,*) ' inside updcrc'
  809.     do i=1,n
  810. c        write(8,*) high,low,byte'
  811. c        write(8,1000),high,low,bbyte
  812.  1000        format(3z10)
  813.         byte=bbyte(i)
  814.  
  815.         do j=1,8
  816. c  get high bits of bytes so we don't lose them when shift
  817. c  positive is left shift
  818.             bit =ishft( iand(128,byte), -7)
  819.             bitl=ishft( iand(128,low),  -7)
  820.             bith=ishft( iand(128,high), -7)
  821. c            write(8,*) 'bit,bitl,bith'
  822. c            write(8,1000),bit,bitl,bith
  823. c  get ready for next iteration
  824.             newbyte=ishft(byte,1)
  825.             byte=newbyte        ! introduced dummy variable newb
  826.                         ! to avoid "access violation"
  827. c            write(8,*) ' byte ready for next iteration'
  828. c            write(8,1000),byte
  829. c  shift those bits in
  830.             low =ishft(low ,1)+bit
  831.             high=ishft(high,1)+bitl
  832. c            write(8,*),' high,low after shifting bits in'
  833. c            write(8,1000),high,low
  834.  
  835.             if(bith.eq.1) then
  836.                 high=ieor(16,high)
  837.                 low=ieor(33,low)
  838. c                write(8,*) ' high,low  after xor'
  839. c                write(8,1000) high,low
  840.             endif
  841.         enddo
  842.     enddo
  843.     return
  844.     end
  845. c-----------------------------------------------------------
  846. c    subroutine fincrc
  847. c  finish CRC calculation for sending    result in high, low
  848. c  merely runs updcrc with two  zero bytes
  849. c    integer high,low
  850. c    common /crcval/high,low
  851. c
  852. c    byte=0
  853. c    call updcrc(byte)
  854. c    call updcrc(byte)
  855. c    return
  856. c    end
  857. c-----------------------------------------------------------
  858.       SUBROUTINE TTYIN(LINE,N)
  859.       BYTE LINE(*)
  860.       INTEGER N
  861. C              READ CHARACTERS FROM TERMINAL
  862. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE
  863. C              MAY HAVE PROBLEM WITH TYPE-AHEAD
  864. c  should convert to time-out properly with loops in main ?
  865.       INCLUDE 'QIO.DCK'
  866. c      INCLUDE '($SSDEF)'
  867.       parameter ss$_timeout='22c'x
  868.       INTEGER I
  869.       INTEGER SYS$QIOW
  870.       INTEGER*4 terminators(2)
  871.  
  872. c      logical crc
  873. c      integer checksum
  874. c      common /checks/checksum,crc
  875.  
  876.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
  877.       DATA terminators/0,0/
  878. C
  879.     write(8,*) ' inside ttyin, N=',N
  880.       I = SYS$QIOW(,           !EVENT FLAG
  881.      -              %VAL(CHAN),         !CHANNEL
  882.      -              %VAL(%LOC(IO$_TTYREADALL).OR.
  883.      -                   %LOC(IO$M_NOECHO)),         !   .OR.%LOC(IO$M_TIMED)),
  884.      -              STATUS,,,
  885.      -              LINE,       !BUFFER
  886.      -              %VAL(N),    !LENGTH
  887.      -              ,        ! max time   beware other disk time
  888.      -                !            and Quit or Retry time
  889.      -              terminators,,)  !no terminators
  890. c      if(crc) then
  891. c         write(8,1000) (LINE(j),j=1,N)
  892. c         write(8,*) ' status=',STATUS
  893. c      else
  894. c         write(8,2000) (line(j),j=1,N)
  895. c         write(8,*) ' status=',status
  896. c      endif
  897.  1000 format(' ttyin=',6(20z3/),10z3)
  898.  2000 format(' ttyin=',6(20z3/),9z3)
  899. c      if(STATUS(1).EQ.SS$_TIMEOUT) THEN
  900. c         write(8,*) ' 10 second timeout in ttyin'
  901. c         print*,    ' 10 second timeout in ttyin'
  902. c         call exit
  903. c      endif
  904.  
  905.       IF (I) THEN
  906. c        write(8,*) ' returning from ttyin'
  907.          return
  908.       endif
  909. C
  910. C              ERROR
  911.       write(8,*) ' ttyin error.'
  912.       CALL SYS$EXIT( %VAL(I) )
  913.       END
  914. c-----------------------------------------------------------
  915.     subroutine eat
  916. c  eats extra characters 'til 1 second pause   used to re-synch after error
  917.     byte buffer(135)
  918.     integer numchar
  919.     logical i,ttyinlim
  920. c
  921.     parameter maxtime=1
  922. c  in case mis-interpreted header, allow at least 1 block of garbage
  923.     numchar=135
  924.  
  925.     i=ttyinlim(buffer,numchar,maxtime)
  926. c    print*,' finished eating'
  927. c    write(8,*) ' finished eating'
  928.     return
  929.     end
  930. c-----------------------------------------------------------
  931.       LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT)
  932.       BYTE LINE(*)
  933.       INTEGER N,LIMIT
  934. C              READ CHARACTERS FROM TERMINAL
  935. C              WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS
  936. C              RECEIVED FOR LIMIT SECONDS
  937. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM
  938. C              MAY HAVE PROBLEM WITH TYPE-AHEAD
  939.       INCLUDE 'QIO.DCK'
  940. c      INCLUDE '($SSDEF)'    ! defines error status returns
  941.       parameter ss$_timeout='22c'x
  942.       INTEGER I
  943.       INTEGER SYS$QIOW
  944.       INTEGER*4 terminators(2)
  945.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
  946.       DATA TERMINATORS/0,0/
  947. C
  948. c    write(8,*) ' inside ttyinlim'
  949.       TTYINLIM=.TRUE.          ! DEFAULT no delay over LIMIT seconds
  950.       I = SYS$QIOW(,           !EVENT FLAG
  951.      -              %VAL(CHAN),         !CHANNEL
  952.      -              %VAL(%LOC(IO$_TTYREADALL).OR.
  953.      -                   %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)),
  954.      -              STATUS,,,
  955.      -              LINE,       !BUFFER
  956.      -              %VAL(N),   !LENGTH
  957.      -              %VAL(LIMIT),    !time limit in seconds
  958.      -              terminators,,)  !no terminators
  959. c     print*,' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  960. c     write(8,*) ' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  961.       if(STATUS(1).EQ.SS$_TIMEOUT) THEN
  962.          TTYINLIM=.FALSE.
  963.          write(8,*) ' timeout'
  964.          return
  965.       ENDIF
  966.  
  967.       IF (I) THEN
  968. c        write(8,*) ' returning from ttyinlim'
  969.          return
  970.       endif
  971. C
  972. C              ERROR
  973.       write(8,*) ' ttyinlim error.'
  974.       CALL SYS$EXIT( %VAL(I) )
  975.       END
  976. c-----------------------------------------------------------
  977.       SUBROUTINE TTYOUT(LINE,N)
  978.       BYTE LINE(*)
  979.       INTEGER*2 N
  980. C  output N characters without interpretation
  981.       INCLUDE 'QIO.DCK'
  982.       INTEGER I
  983.       INTEGER SYS$QIOW
  984.       EXTERNAL IO$M_NOFORMAT
  985.       EXTERNAL IO$_WRITEVBLK
  986. C
  987.       IF ( N.LE.0 ) RETURN
  988. C
  989. c    print *, ' to be sent by ttyout ', line(1)
  990.       I = SYS$QIOW(,
  991.      -              %VAL(CHAN),
  992.      -              %VAL(%LOC(IO$_WRITEVBLK).OR.
  993.      -                   %LOC(IO$M_NOFORMAT)),
  994.      -              STATUS,,,
  995.      -              LINE,
  996.      -              %VAL(N),,
  997.      -              %VAL(0),, )         !NO CARRIAGE CONTROL
  998.       if(I) then
  999.          return
  1000.       endif
  1001. C
  1002. C              ERROR
  1003.       write(8,*) ' ttyout error.'
  1004.       CALL SYS$EXIT( %VAL(I) )
  1005.       END
  1006. c--------------------------------------------------
  1007.     subroutine giveup
  1008. c  this exit routine used especially in case exited via QIO problem
  1009.     include 'qio.dck'
  1010.  
  1011. c  note: if want log file message, must re-open since
  1012. c  system already closed all files before this exit handler got control
  1013. c    open(8,file='XMODEM.LOG',access='APPEND')
  1014. c    write(8,*) ' Exit handler.'
  1015.  
  1016. c  turn off passall
  1017.     call passall(CHAN,.FALSE.)
  1018.     return
  1019.     end
  1020. c-----------------------------------------------------
  1021.     SUBROUTINE PASSALL(CHAN,SWITCH)
  1022. C  sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true
  1023.     IMPLICIT INTEGER (A-Z)
  1024. c    INCLUDE '($TTDEF)'
  1025.     parameter tt$m_passall=1
  1026.     parameter tt$m_eightbit='8000'x
  1027.     parameter io$_sensemode='27'x
  1028.     parameter io$_setmode='23'x
  1029. c    INCLUDE '($IODEF)'
  1030.     LOGICAL SWITCH
  1031.     COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH    !byte reversed LENGTH
  1032.     BYTE CLASS,TYPE,CHARAC,LENGTH
  1033.     INTEGER*2 WIDTH,SPEED
  1034.     EQUIVALENCE(CHARACTER,CHARAC)
  1035.  
  1036. c  sense current terminal driver mode
  1037.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,,
  1038.     1 CLASS,,,,,)
  1039.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT)
  1040.  
  1041.     IF(SWITCH) THEN
  1042. c  turn on 8 bit passall
  1043.         CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR.
  1044.     1                TT$M_EIGHTBIT
  1045.     ELSE
  1046. c  turn off 8 bit passall
  1047.         CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND.
  1048.     1                               .NOT.TT$M_EIGHTBIT
  1049.     ENDIF
  1050.     SPEED=0    !LEAVE SPEED UNCHANGED
  1051.     PAR=0    !LEAVE PARITY UNCHANGED
  1052.  
  1053. c  set terminal mode with desired passall
  1054.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,,
  1055.     1               CLASS,,%VAL(SPEED),,%VAL(PAR),)
  1056.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT)
  1057.     RETURN
  1058.     END
  1059. c---------------------------------------------------
  1060.     SUBROUTINE ERROR(STRING,MSGID)
  1061. c        Types error message
  1062.     IMPLICIT INTEGER(A-Z)
  1063.     CHARACTER*(*) STRING
  1064.     CHARACTER*80 MESSAGE
  1065.  
  1066.     TYPE *,' *** ERROR: ',STRING
  1067.     write(8,*) ' *** ERROR: ',STRING
  1068.     CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),)
  1069.     TYPE *,MESSAGE(1:MSGLEN),CRLF
  1070.     write(8,*) MESSAGE(1:MSGLEN),CRLF
  1071.     RETURN
  1072.     END
  1073. c-----------------------------------------------------------
  1074.     subroutine cancel
  1075.     INCLUDE 'QIO.DCK'
  1076. c  called to cancel send (at least)
  1077.     logical charintime,ttyinlim
  1078.     byte c
  1079.     parameter CAN=24
  1080.     parameter SPACE=32
  1081.  
  1082. c  eat garbage
  1083.   100    charintime=ttyinlim(c,1,1)
  1084.     if(.NOT.charintime) goto 100
  1085. c  cancel other end
  1086.     call ttyout(CAN,1)
  1087.  
  1088. c  eat garbage in case it didn't understand ?
  1089.   200    charintime=ttyinlim(c,1,1)
  1090.     if(.NOT.charintime) goto 200
  1091. c  clear the CAN from far end's input  ???? why ? xmodem50.asm does it
  1092.     call ttyout(SPACE,1)
  1093.  
  1094. c    print*,' XMODEM program canceled'
  1095.     write(8,*)' XMODEM program canceled'
  1096.     call exit
  1097.     end
  1098. c------------------------------------------------------
  1099.     subroutine getack(acked)
  1100. c  returns .TRUE. if gets ACK
  1101.     logical charintime, ttyinlim, acked
  1102.     byte sector(130),c
  1103.  
  1104.     integer errorcount
  1105.     common /err/errorcount
  1106.  
  1107.     parameter ACK=6
  1108.     parameter errlim=10    ! max number of errors
  1109.     parameter eotlim=10    ! seconds to wait for eot
  1110.  
  1111. c    print*,' inside getack'
  1112. c  empty typeahead in case garbage
  1113. c    charintime=ttyinlim(sector,130,0)
  1114. c  allow time for file close at other end.
  1115.     charintime=ttyinlim(c,1,eotlim)
  1116. c    print*,' getack got',c
  1117.     if( .NOT.charintime .OR. c.NE.ACK ) then
  1118. c        print*, ' not ACK, decimal=',c
  1119.         write(8,*) ' not ACK, decimal=',c
  1120.         errorcount=errorcount+1
  1121.         if(errorcount.GE.errlim) then
  1122.             write(8,*) ' not acknowleged in 10 tries.'
  1123.             print*,' Can''t send sector. Aborting.'
  1124.             call exit
  1125.         endif
  1126.         acked=.FALSE.
  1127.     else
  1128. c  received ACK
  1129.         acked=.TRUE.
  1130.     endif
  1131.     return
  1132.     end
  1133. 
  1134.